
      SUBROUTINE COLLIS                                                 0447

c	include 'tcommon.for'
	%include tcommon.for

C     ...SUBROUTINE TO DETERMINE ALL POSSIBLE COLLISIONS                0474
C     ...E COLLISION WITH *                                             0475
      IF(NSTARS.EQ.0)GO TO 115                                          0476
      DO 100 I=1,NSTARS                                                 0477
      IF(STARS(I,1).EQ.0.)GO TO 100                                     0478
      IF(RANGE(XQE,STARS(I,1),YQE,STARS(I,2)).GT.RAD(I))GO TO 100       0479
      CALL RATING(1)                                                    0480
100   CONTINUE                                                          0481
C     ...SUPERNOVA?                                                     0482
110   IF(RAN(IZZ).GT.SNOVAP)GO TO 115                                   0483
      NS=NSTARS*RAN(IZZ)+1.                                             0484
1101  WRITE(6,111)NS                                                    0485
111   FORMAT(' STAR ',I1,' GOING SUPERNOVA!!')                          0486
      NTORPS=0                                                          0487
      IF(IGH.EQ.0)GO TO 1111                                            0488
      CALL DLETE(5,1)                                                   0489
1111  DO 1112 I=1,NSTARS                                                0490
      IF(STARS(I,1).EQ.0.)GO TO 1112                                    0491
      CALL DLETE(1,I)                                                   0492
1112  CONTINUE                                                          0493
      IF(NROM.EQ.0)GO TO 1114                                           0494
      DO 1113 I=1,NROM                                                  0495
      IF(XROM(I,1).EQ.0.)GO TO 1113                                     0496
      CALL DLETE(4,I)                                                   0497
1113  CONTINUE                                                          0498
1114  IF(KLNGNS.EQ.0)GO TO 1116                                         0499
      DO 1115 I=1,KLNGNS                                                0500
      IF(XKL(I,1).EQ.0.)GO TO 1115                                      0501
      CALL DLETE(3,I)                                                   0502
1115  CONTINUE                                                          0503
1116  IF(IBASE.EQ.0)GO TO 1117                                          0504
      CALL DLETE(6,1)                                                   0505
1117  X=DEFL                                                            0506
      IF(X.EQ.0.)GO TO 1118                                             0507
      X=300000./X                                                       0508
      IF(X.GT.ZMAX)GO TO 1118                                           0509
      GO TO 1119                                                        0510
1118  X=ZMAX                                                            0511
1119  WRITE(6,11911)                                                    0512
11911 FORMAT(' SHIELDS DESTROYED')                                      0513
      CALL DAMAGE(-1,X)                                                 0514
      DEFL=0.                                                           0515
      IF(ISTSH.EQ.0)GO TO 115                                           0516
      WRITE(6,1120)                                                     0517
1120  FORMAT(' SHUTTLECRAFT DESTROYED')                                 0518
      DO 1121 I=1,9                                                     0519
1121  IFNDS(I)=0                                                        0520
      ISTSH=0                                                           0521
      ISHD=0                                                            0522
      ISHNUM=ISHNUM-1                                                   0523
C     ...E WITH K.                                                      0524
115   IF(IDOCK.EQ.2)GO TO 210                                           0525
      IF(KLNGNS.EQ.0)GO TO 130						
      DO 120   I=1,KLNGNS						
      IF(XKL(I,1).EQ.0.)GO TO 120                                       0528
      IF(RANGE(XQE,XKL(I,1),YQE,XKL(I,2)).GT.RADEK)GO TO 120            0529
      WRITE(6,1)LETR(2),LETR(3),I                                       0530
1     FORMAT(1X,A1,'-',A1,I1,' COLLISION')                              0531
      CALL DLETE(3,I)                                                   0532
      WRITE(6,2)                                                        0533
2     FORMAT(' SHIELDS DESTROYED')                                      0534
      CALL DAMAGE(0,DEFL)                                               0535
120   CONTINUE                                                          0536
C     ...E WITH R.                                                      0537
130   IF(NROM.EQ.0)GO TO 150                                            0538
      DO 140    I=1,NROM                                                0539
      IF(XROM(I,1).EQ.0.)GO TO 140                                      0540
      IF(RANGE(XQE,XROM(I,1),YQE,XROM(I,2)).GT.RADER)GO TO 140          0541
      WRITE(6,1)LETR(2),LETR(4),I                                       0542
      CALL DLETE(4,I)                                                   0543
      WRITE(6,2)                                                        0544
      CALL DAMAGE(0,DEFL)                                               0545
140   CONTINUE                                                          0546
C     ...E WITH G.                                                      0547
150   IF(IGH.EQ.0)GO TO 170                                             0548
      IF(RANGE(XQE,GHOST(1),YQE,GHOST(2)).GT.RADEG)GO TO 170            0549
      WRITE(6,7)LETR(2),LETR(5)                                         0550
      CALL DLETE(5,1)                                                   0551
      WRITE(6,2)                                                        0552
      CALL DAMAGE(0,DEFL)                                               0553
C     ...E WITH B. MAY BE DOCKING.                                      0554
170   IF(IBASE.EQ.0)GO TO 190                                           0555
      IF(RANGE(XQE,BASE(1),YQE,BASE(2)).GT.RADEB)GO TO 190              0556
      IF(PSP.LE.DMXSPD)GO TO 180                                        0557
      WRITE(6,7)LETR(2),LETR(6)                                         0558
      CALL DLETE(6,1)                                                   0559
      WRITE(6,2)                                                        0560
      CALL DAMAGE(0,DEFL)                                               0561
      GO TO 190                                                         0562
180   IDOCK=1                                                           0563
      GO TO 210                                                         0564
C     ...E WITH T.                                                      0565
190   IF(NTORPS.EQ.0)GO TO 205                                          0566
      DO 200    I=1,NTORPS                                              0567
      IF(TORPS(I,1).EQ.0.)GO TO 200                                     0568
      X=RANGE(XQE,TORPS(I,1),YQE,TORPS(I,2))                            0569
      IF(X.GT.RADET)GO TO 200                                           0570
C     ...E FIRED TORPS CAN'T HURT E.                                    0571
      IF(TORPS(I,4).LT.0.)GO TO 200                                     0572
      Y=AMAX1(TPMIN,(1.-X**2/RADET**2)*TPOWR)/SHLDF                     0573
      WRITE(6,3)LETR(7),LETR(2)                                         0574
3     FORMAT(1X,A1,' HIT ON ',A1)                                       0575
      CALL HITONE(Y)                                                    0576
      CALL DLETE(7,I)                                                   0577
200   CONTINUE                                                          0578
C     ...E WITH BLACK HOLE.                                             0579
205   IF(IHOLE.EQ.0)GO TO 210                                           0580
      IF(RANGE(XQE,FLOAT(IHOLE),YQE,FLOAT(JHOLE)).GT.HOLRAD)GO TO 210   0581
      WRITE(6,206)LETR(2)                                               0582
206   FORMAT(1X,A1,' CAPTURED BY BLACK HOLE GRAVITATION FIELD!')        0583
      IS=-1                                                             0584
      CALL EPMOVE(IS)                                                   0585
      GO TO 999                                                         0586
C     ...K WITH *                                                       0587
210   IF(KLNGNS.EQ.0)GO TO 330                                          0588
      IF(NSTARS.EQ.0)GO TO 230                                          0589
      DO 220    I=1,KLNGNS                                              0590
      IF(XKL(I,1).EQ.0.)GO TO 220                                       0591
      DO 225    J=1,NSTARS                                              0592
      IF(STARS(J,1).EQ.0.)GO TO 225                                     0593
      IF(RANGE(XKL(I,1),STARS(J,1),XKL(I,2),STARS(J,2)).GT.RAD(I))GO TO 0594
     1225                                                               0595
      WRITE(6,1)LETR(1),LETR(3),I                                       0596
      IF(RAN(IZZ).GT.SNOVAP)GO TO 224                                   0597
      NS=J                                                              0598
      GO TO 1101                                                        0599
224   CALL DLETE(3,I)                                                   0600
      CALL DLETE(1,J)                                                   0601
225   CONTINUE                                                          0602
220   CONTINUE                                                          0603
C     ...K WITH K.                                                      0604
230   IF(KLNGNS.LE.1)GO TO 250                                          0605
      DO 240 I=1,KLNGNS                                                 0606
      IF(XKL(I,1).EQ.0.)GO TO 240                                       0607
      DO 245    J=1,KLNGNS                                              0608
      IF(XKL(J,1).EQ.0.)GO TO 245                                       0609
      IF(J.EQ.I)GO TO 245                                               0610
      IF(RANGE(XKL(I,1),XKL(J,1),XKL(I,2),XKL(J,2)).GT.RADKK)GO TO 245  0611
      WRITE(6,5)LETR(3),I,LETR(3),J                                     0612
5     FORMAT(1X,A1,I1,'-',A1,I1,' COLLISION')                           0613
      CALL DLETE(3,I)                                                   0614
      CALL DLETE(3,J)                                                   0615
245   CONTINUE                                                          0616
240   CONTINUE                                                          0617
C     ...K WITH R.                                                      0618
250   IF(KLNGNS.EQ.0)GO TO 330                                          0619
      IF(NROM.EQ.0)GO TO 270                                            0620
      DO 260 I=1,KLNGNS                                                 0621
      IF(XKL(I,1).EQ.0.)GO TO 260                                       0622
      DO 265    J=1,NROM                                                0623
      IF(XROM(J,1).EQ.0.)GO TO 265                                      0624
      IF(RANGE(XKL(I,1),XROM(J,1),XKL(I,2),XROM(J,2)).GT.RADKR)GO TO 2650625
      WRITE(6,5)LETR(3),I,LETR(4),J                                     0626
      CALL DLETE(3,I)                                                   0627
      CALL DLETE(4,J)                                                   0628
265   CONTINUE                                                          0629
260   CONTINUE                                                          0630
C     ...K WITH G.                                                      0631
270   IF(KLNGNS.EQ.0)GO TO 330                                          0632
      DO 280    I=1,KLNGNS                                              0633
      IF(XKL(I,1).EQ.0.)GO TO 280                                       0634
      IF(IGH.EQ.0)GO TO 290                                             0635
      IF(RANGE(XKL(I,1),GHOST(1),XKL(I,2),GHOST(2)).GT.RADKG)GO TO 280  0636
      WRITE(6,1)LETR(5),LETR(3),I                                       0637
      CALL DLETE(3,I)                                                   0638
      CALL DLETE(5,1)                                                   0639
280   CONTINUE                                                          0640
C     ...K WITH B.                                                      0641
290   IF(KLNGNS.EQ.0)GO TO 330                                          0642
      IF(IBASE.EQ.0)GO TO 310                                           0643
      DO 300    I=1,KLNGNS                                              0644
      IF(XKL(I,1).EQ.0.)GO TO 300                                       0645
      IF(RANGE(XKL(I,1),BASE(1),XKL(I,2),BASE(2)).GT.RADKB)GO TO 300    0646
      WRITE(6,1)LETR(6),LETR(3),I                                       0647
      CALL DLETE(3,I)                                                   0648
      CALL DLETE(6,1)                                                   0649
      IF(IDOCK.EQ.2)IDOCK=0                                             0650
300   CONTINUE                                                          0651
C     ...K WITH T.                                                      0652
310   IF(KLNGNS.EQ.0)GO TO 330                                          0653
      IF(NTORPS.EQ.0)GO TO 326                                          0654
      DO 320    I=1,KLNGNS                                              0655
      IF(XKL(I,1).EQ.0.)GO TO 320                                       0656
      DO 325  J=1,NTORPS                                                0657
      IF(TORPS(J,1).EQ.0.)GO TO 325                                     0658
      IF(RANGE(XKL(I,1),TORPS(J,1),XKL(I,2),TORPS(J,2)).GT.RADKT)GO TO 30659
     125                                                                0660
      IF(TORPS(J,4).LT.360..AND.TORPS(J,4).GE.0.)GO TO 325              0661
      WRITE(6,6)LETR(7),LETR(3),I,XKL(I,1),XKL(I,2)                     0662
6     FORMAT(1X,A1,' HIT ON ',A1,I1,' AT ',F4.1,',',F4.1)               0663
      CALL DLETE(3,I)                                                   0664
      CALL DLETE(7,J)                                                   0665
325   CONTINUE                                                          0666
320   CONTINUE                                                          0667
C     ...K WITH BLACK HOLE.                                             0668
326   IF(IHOLE.EQ.0)GO TO 330                                           0669
      DO 327 I=1,KLNGNS                                                 0670
      IF(XKL(I,1).EQ.0.)GO TO 327                                       0671
      IF(RANGE(XKL(I,1),FLOAT(IHOLE),XKL(I,2),FLOAT(JHOLE)).GT.HOLRAD)GO0672
     1 TO 327                                                           0673
      KCE=IBL(ICE,JCE)/100                                              0674
      LCE=IBL(ICE,JCE)-KCE*100                                          0675
      M=JGAL(KCE,LCE)                                                   0676
      WRITE(6,3261)LETR(3),I                                            0677
3261  FORMAT(1X,A1,I1,' CAPTURED BY BLACK HOLE')                        0678
      IF(M-M/1000*1000.LT.900)GO TO 3263                                0679
      CALL DLETE(3,I)                                                   0680
      GO TO 3265                                                        0681
3263  WRITE(6,3262)KCE,LCE                                              0682
3262  FORMAT(' ESCAPED TO QUADRANT ',I2,',',I2)                         0683
      JGAL(ICE,JCE)=JGAL(ICE,JCE)-100                                   0684
      IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0)IGAL(ICE,JCE)=JGAL(ICE,JCE)       0685
      JGAL(KCE,LCE)=M+100                                               0686
3265  J J=I                                                             0687
      IF(ITRMEN(JJ+1).EQ.0)GO TO 97531                                  0688
      IF(XKL(I,1).EQ.0.)GO TO 97532                                     0689
      WRITE(6,97530)ITRMEN(JJ+1)                                        0690
97530 FORMAT(I4,' TROOPS CAPTURED BY ENEMY')                            0691
      GO TO 97533                                                       0692
97532 WRITE(6,97534)ITRMEN(JJ+1)                                        0693
97534 FORMAT(I4,' TROOPS ON BOARD LOST')                                0694
97533 ITRMEN(JJ+1)=0                                                    0695
      IF(ISTAT.EQ.0)GO TO 97531                                         0696
C     ...STOP BEAMING.                                                  0697
      IF(JUP.EQ.3.AND.JFROM.EQ.JJ.OR.JDOWN.EQ.3.AND.JTO.EQ.JJ)ISTAT=99990698
97531 ICNTL(JJ+1)=0                                                     0699
      XKL(JJ,1)=0.                                                      0700
327   CONTINUE                                                          0701
C     ...T WITH *.                                                      0702
330   IF(NTORPS.EQ.0)GO TO 440                                          0703
      IF(NSTARS.EQ.0)GO TO 350                                          0704
      DO 340    I=1,NTORPS                                              0705
      IF(TORPS(I,1).EQ.0.)GO TO 340                                     0706
      DO 345  J=1,NSTARS                                                0707
      IF(STARS(J,1).EQ.0.)GO TO 345                                     0708
      IF(RANGE(TORPS(I,1),STARS(J,1),TORPS(I,2),STARS(J,2)).GT.       RA0709
     1D(I))GO TO 345                                                    0710
      IF(RAN(IZZ).GT.SNOVAP)GO TO 344                                   0711
      NS=J                                                              0712
      GO TO 1101                                                        0713
344   CALL DLETE(7,I)                                                   0714
      CALL DLETE(1,J)                                                   0715
      IF(NROM.EQ.0)GO TO 345                                            0716
      IF(TORPS(I,4).GE.360..OR.TORPS(I,4).LT.0.)GO TO 345               0717
      IF(RAN(IZZ).GT.PRORAS)GO TO 345                                   0718
      WRITE(6,341)                                                      0719
341   FORMAT(' OUTRAGED ALIENS DESTROY EVERY ROMULAN IN QUADRANT'/      0720
     1' IN RETALIATION FOR DESTRUCTION OF THEIR STAR SYSTEM!')          0721
      DO 342 K=1,NROM                                                   0722
      IF(XROM(K,1).EQ.0.)GO TO 342                                      0723
      CALL DLETE(4,K)                                                   0724
342   CONTINUE                                                          0725
345   CONTINUE                                                          0726
340   CONTINUE                                                          0727
C     ...T WITH R.                                                      0728
350   IF(NTORPS.EQ.0)GO TO 440                                          0729
      IF(NROM.EQ.0)GO TO 370                                            0730
      DO 360    I=1,NTORPS                                              0731
      IF(TORPS(I,1).EQ.0.)GO TO 360                                     0732
      DO 355 J=1,NROM                                                   0733
      IF(XROM(J,1).EQ.0.)GO TO 355                                      0734
      IF(RANGE(TORPS(I,1),XROM(J,1),TORPS(I,2),XROM(J,2)).GT.RADTR)     0735
     1  GO TO 355                                                       0736
      IF(TORPS(I,4).LT.360.AND.TORPS(I,4).GE.0.)GO TO 355               0737
      IF(ICNTL(J+10).EQ.1.AND.TORPS(I,4).LT.0.)GO TO 355                0738
      WRITE(6,6)LETR(7),LETR(4),J,XROM(J,1),XROM(J,2)                   0739
      CALL DLETE(4,J)                                                   0740
      CALL DLETE(7,I)                                                   0741
355   CONTINUE                                                          0742
360   CONTINUE                                                          0743
C     ...T WITH G.                                                      0744
370   IF(NTORPS.EQ.0)GO TO 440                                          0745
      IF(IGH.EQ.0)GO TO 390                                             0746
      DO 380    I=1,NTORPS                                              0747
      IF(TORPS(I,1).EQ.0.)GO TO 380                                     0748
      X=RANGE(TORPS(I,1),GHOST(1),TORPS(I,2),GHOST(2)   )               0749
      IF(X.GT.RADGT)GO TO 380                                           0750
C     ...G FIRED T CAN'T HURT G.                                        0751
      IF(TORPS(I,4).GE.360.)GO TO 380                                   0752
      WRITE(6,3)LETR(7),LETR(5)                                         0753
      CALL DLETE(7,I)                                                   0754
      Y=AMAX1(TPMIN,(1.-X**2/RADGT**2)*TPOWR)                           0755
      GHOST(13)=GHOST(13)-Y                                             0756
      IF(GHOST(13).GE.0.)GO TO 380                                      0757
      Y=GHOST(13)                                                       0758
      GHOST(13)=0.                                                      0759
      GHOST(3)=GHOST(3)-Y                                               0760
      IF(GHOST(3).LT.XGHIT)GO TO 380                                    0761
      CALL DLETE(5,1)                                                   0762
      GO TO 390                                                         0763
380   CONTINUE                                                          0764
C     ...T WITH B.                                                      0765
390   IF(NTORPS.EQ.0)GO TO 440                                          0766
      IF(IBASE.EQ.0)GO TO 410                                           0767
      DO 400    I=1,NTORPS                                              0768
      IF(TORPS(I,1).EQ.0.)GO TO 400                                     0769
      X=RANGE(TORPS(I,1),BASE(1),TORPS(I,2),BASE(2)   )                 0770
      IF(X.GT.RADBT)GO TO 400                                           0771
      CALL DLETE(7,I)                                                   0772
400   CONTINUE                                                          0773
C     ...T WITH T.                                                      0774
410   IF(NTORPS.EQ.0)GO TO 440                                          0775
      DO 420    I=1,NTORPS                                              0776
      IF(TORPS(I,1).EQ.0.)GO TO 420                                     0777
      DO 425    J=1,NTORPS                                              0778
      IF(TORPS(J,1).EQ.0.)GO TO 425                                     0779
      IF(J.EQ.I)GO TO 425                                               0780
      IF(RANGE(TORPS(I,1),TORPS(J,1),TORPS(I,2),TORPS(J,2)).GT.RADTT    0781
     1   )GO TO 425                                                     0782
      IF(RAN(IZZ).GT.PCTCOL)GO TO 425                                   0783
      IF(TORPS(I,4).LT.0..AND.TORPS(J,4).LT.0.)GO TO 425                0784
      WRITE(6,7)LETR(7),LETR(7)                                         0785
7     FORMAT(1X,A1,'-',A1,' COLLISION')                                 0786
      CALL DLETE(7,I)                                                   0787
      CALL DLETE(7,J)                                                   0788
425   CONTINUE                                                          0789
420   CONTINUE                                                          0790
C     ...T WITH HOLE.                                                   0791
      IF(NTORPS.EQ.0)GO TO 440                                          0792
      IF(IHOLE.EQ.0)GO TO 440                                           0793
      DO 430 I=1,NTORPS                                                 0794
      IF(TORPS(I,1).EQ.0.)GO TO 430                                     0795
      IF(RANGE(TORPS(I,1),FLOAT(IHOLE),TORPS(I,2),FLOAT(JHOLE)).GT.HOLRA0796
     1D)GO TO 430                                                       0797
      CALL DLETE(7,I)                                                   0798
430   CONTINUE                                                          0799
C     ...G WITH *.                                                      0800
440   IF(IGH.EQ.0)GO TO 999                                             0801
      IF(NSTARS.EQ.0)GO TO 460                                          0802
      DO 450 I=1,NSTARS                                                 0803
      IF(STARS(I,1).EQ.0.)GO TO 450                                     0804
      IF(RANGE(STARS(I,1),GHOST(1),STARS(I,2),GHOST(2)).GT.RAD(I))      0805
     1GO TO 450                                                         0806
      WRITE(6,1)LETR(5),LETR(1),I                                       0807
      IF(RAN(IZZ).GT.SNOVAP)GO TO 445                                   0808
      NS=I                                                              0809
      GO TO 1101                                                        0810
445   CALL DLETE(1,I)                                                   0811
      CALL DLETE(5,1)                                                   0812
      GO TO 999                                                         0813
450   CONTINUE                                                          0814
C     ...G WITH R.                                                      0815
460   IF(NROM.EQ.0)GO TO 480                                            0816
      DO 470    I=1,NROM                                                0817
      IF(XROM(I,1).EQ.0.)GO TO 470                                      0818
      IF(RANGE(XROM(I,1),GHOST(1),XROM(I,2),GHOST(2)).GT.RADGR)      GO 0819
     1TO 470                                                            0820
      WRITE(6,1)LETR(5),LETR(4),I                                       0821
      CALL DLETE(4,I)                                                   0822
      CALL DLETE(5,1)                                                   0823
      GO TO 999                                                         0824
470   CONTINUE                                                          0825
C     ...G WITH B.                                                      0826
480   IF(IBASE.EQ.0)GO TO 490                                           0827
      IF(RANGE(GHOST(1),BASE(1),GHOST(2),BASE(2)).GT.RADGB)      GO TO 90828
     199                                                                0829
      WRITE(6,7)LETR(5),LETR(6)                                         0830
      CALL DLETE(6,1)                                                   0831
      CALL DLETE(5,1)                                                   0832
      IF(IDOCK.EQ.2)IDOCK=0                                             0833
C     ...G WITH HOLE.                                                   0834
490   IF(IHOLE.EQ.0)GO TO 999                                           0835
      IF(RANGE(GHOST(1),FLOAT(IHOLE),GHOST(2),FLOAT(JHOLE)).GT.HOLRAD)GO0836
     1 TO 999                                                           0837
      CALL DLETE(5,1)                                                   0838
999   RETURN                                                            0839
      END                                                               0840
